home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / prog / iconp.zip / CROSS.ICN < prev    next >
Text File  |  1987-05-29  |  4KB  |  153 lines
  1. #    CROSS(6)
  2. #
  3. #    Display intersection of words
  4. #
  5. #    William P. Malloy
  6. #
  7. #    Last modified 8/14/84
  8. #
  9.  
  10. global fast, place, array, csave, fsave, number
  11.  
  12. procedure main()
  13.    local opt, words, letter, line
  14.    letter := &lcase ++ &ucase
  15.    words := []
  16.    while line := map(read()) do
  17.       if upto(~letter,line) then stop("input contains nonletter")
  18.       else put(words,line)
  19.    number := *words
  20.    kross(words)
  21. end
  22.  
  23. procedure kross(words)
  24.    local one, tst, t
  25.    array := [get(words)]
  26.    t := 0
  27.    while one := get(words) do {
  28.       tst := *words
  29.       if fit(one,array,0 | 1) then
  30.      t := 0
  31.       else {
  32.      t +:= 1
  33.          put(words,one)
  34.      if t > tst then
  35.         break
  36.      }
  37.       }
  38.    if *words = 0 then Print(array)
  39.    else write("cannot construct puzzle")
  40. end
  41.  
  42. procedure fit(word,matrix,where)
  43.    local i, j, k, l, one, test, t, s
  44.    s := *matrix
  45.    t := *matrix[1]
  46.    every k := gen(*word) do
  47.       every i := gen(s) do
  48.          every j := gen(t) do
  49.         if matrix[i][j] == word[k] then {
  50.                # test for vertical fit
  51.                if where = 0 then {
  52.                   test := 0
  53.                   every l := (i - k + 1) to (i + (*word - k)) do
  54.                      if tstv(matrix,i,j,l,s,t) then {
  55.                         test := 1
  56.                         break
  57.                         }
  58.                   if test = 0 then
  59.                      return putvert(matrix,word,i,j,k)
  60.                   }
  61.                if where = 1 then {
  62.                   test := 0
  63.                   every l := (j - k + 1) to (j + (*word - k)) do
  64.                      if tsth(matrix,i,j,l,s,t) then {
  65.                         test := 1
  66.                         break
  67.                         }
  68.                   if test = 0 then
  69.                      return puthoriz(matrix,word,i,j,k)
  70.                   }
  71.                }
  72. end
  73.  
  74. procedure tstv(matrix,i,j,l,s,t)
  75.    return ((matrix[(l ~= i) & (s >= l) & (0 < l)][0 < j-1] ~== " ") |
  76.       (matrix[(l ~= i) & (s >= l) & (0 < l)][t >= j + 1] ~== " ") |
  77.       (matrix[(i ~= l-1) & (s >= l-1) & (0 < l-1)][j] ~== " ") |
  78.       (matrix[(i ~= l + 1) & (s >= l+1) & (0 < l + 1)][j] ~== " ") |
  79.       (matrix[(l ~= i) & (s >= l) & (0 < l)][j] ~== " "))
  80. end
  81.  
  82. procedure tsth(matrix,i,j,l,s,t)
  83.    return ((matrix[0 < i-1][(l ~= j) & (t >= l) & (0 < l)] ~== " ") |
  84.       (matrix[s >= i + 1][(l ~= j) & (t >= l) & (0 < l)] ~== " ") |
  85.       (matrix[i][(j ~= l-1) & (t >= l-1) & (0 < l-1)] ~== " ") |
  86.       (matrix[i][(j ~= l + 1) & (t >= l + 1) & (0 < l + 1)] ~== " ") |
  87.       (matrix[i][(l ~= j) & (t >= l) & (0 < l)] ~== " "))
  88. end
  89.  
  90. procedure gen(i)
  91.    local tmp, up, down
  92.    tmp := i / 2
  93.    if (i % 2) = 1 then
  94.       tmp +:= 1
  95.    suspend tmp
  96.    up := tmp
  97.    down := tmp
  98.    while (up < i) do {
  99.       suspend up +:= 1
  100.       suspend (down > 1) & (down -:= 1)
  101.       }
  102. end
  103.  
  104. # put `word' in vertically at pos(i,j)
  105.  
  106. procedure putvert(matrix,word,i,j,k)
  107.    local hdim, vdim, up, down, l, m, n
  108.    vdim := *matrix
  109.    hdim := *matrix[1]
  110.    up := 0
  111.    down := 0
  112.    up := abs(0 > (i - k))
  113.    down := abs(0 > ((vdim - i) - (*word - k)))
  114.    every m := 1 to up do
  115.       push(matrix,repl(" ",hdim))
  116.    i +:= up
  117.    every m := 1 to down do
  118.       put(matrix,repl(" ",hdim))
  119.    every l := 1 to *word do
  120.       matrix[i + l - k][j] := word[l]
  121.    return matrix
  122. end
  123.  
  124. # put `word' in horizontally at position i,j in matrix
  125.  
  126. procedure puthoriz(matrix,word,i,j,k)
  127.    local hdim, vdim, left, right, l, m, n
  128.    vdim := *matrix
  129.    hdim := *matrix[1]
  130.    left := 0
  131.    right := 0
  132.    left := (abs(0 > (j - k))) | 0
  133.    right := (abs(0 > ((hdim - j) - (*word - k)))) | 0
  134.    every m := 1 to left do
  135.       every l := 1 to vdim do
  136.        matrix[l] := " " || matrix[l]
  137.    j +:= left
  138.    every m := 1 to right do
  139.       every l := 1 to vdim do
  140.       matrix[l] ||:= " "
  141.    every l := 1 to *word do
  142.       matrix[i][j + l - k] := word[l]
  143.    return matrix
  144. end
  145.  
  146. procedure Print(matrix)
  147.    local i
  148.    write("+",repl("-",*matrix[1]),"+")
  149.    every i := 1 to *matrix do
  150.       write("|",matrix[i],"|")
  151.    write("+",repl("-",*matrix[1]),"+")
  152. end
  153.